perm filename OCC[G,BGB] blob
sn#001331 filedate 1973-02-10 generic text, type T, neo UTF8
00100 TITLE OCCULT - A HIDDEN LINE ELIMINATOR - SEPTEMBER 1972.
00200
00300 COMMENT /
00400
00500 /
00600
00700 ;OCCULT IS DEPENDENT ON THE WING PRIMITIVES.
00800 EXTERN GETBLK,RELBLK
00900 EXTERN MKB,MKF,MKE,MKV,MKBFV
01000 EXTERN KLB,KLF,KLE,KLV
01100 EXTERN WING
01200 EXTERN ECW,ECCW,OTHER
01300 EXTERN BODY,FCW,FCCW,VCW,VCCW
01400 EXTERN MKEV,MKFE,ESPLIT,KLEV,KLFE
01500 EXTERN INVERT
01600
01700 ;OCCULT'S CONTEXT - FACE AND EDGE RINGS.
01800 POTNTF ←← 5 ;POTENTIAL VISIBLE FACES.
01900 POTNTE ←← 1 ;POTENTIAL VISIBLE EDGES.
02000 FOLDE ←← 2 ;FOLDED POTENTIAL VISIBLE EDGES.
02100 PIPE ←← 3 ;UNCOMPLETED VISIBLE OR HIDDEN EDGES.
02200 EXTERN WORLD
02300
02400 EXTERN MAGX,MAGY,SOX,SOY
00100 ;E.HIDE(F,E,V) - PUT POTENT EDGE TO BE HIDDEN INTO THE PIPE RING.
00200 SUBR(E.HIDE)
00300 BEGIN E.HIDE
00400 ACCUMULATORS{F,E,V,A,Q,R}
00500 LAC E,ARG2↔TEST E,POTENT↔POP3J ;MUST BE POTENT.
00600 LAC F,ARG3↔ALT A,E ;SAVE UBER-FACE.
00700 NVT V,E↔CAMN V,ARG1↔GO[
00800 NUF. F,A↔MARK A,2B17↔GO L1]
00900 PUF. F,A↔MARK A,1B17
01000 L1: CAR Q,PIPE(A)↔CDR R,PIPE(A) ;RINGO WHEN NOT EMPTY.
01100 JUMPE R,L2↔SAD Q,E↔GO L2
01200 DAP R,PIPE(Q)↔DIP Q,PIPE(R)
01300 L2: LAC Q,WORLD↔CDR R,PIPE(Q) ;RINGIN
01400 DAP A,PIPE(Q)↔DIP A,PIPE(R)
01500 DIP Q,PIPE(A)↔DAP R,PIPE(A)
01600 POP3J
01700 BEND
01800
00100 ;E.SHOW(F,E,V) - PUT POTENT EDGE TO BE SHOWN INTO THE PIPE RING.
00200 SUBR(E.SHOW)
00300 BEGIN E.SHOW
00400 ACCUMULATORS{F,E,V,A,Q,R}
00500 LAC E,ARG2↔TEST E,POTENT↔POP3J ;MUST BE POTENT.
00600 TEST E,FOLDED↔POP3J ;MUST BE FOLDED.
00700 LAC F,ARG3↔ALT A,E ;PROVIDE UNDER-FACE.
00800 NVT V,E↔SAD V,ARG1↔GO[
00900 NUF. F,A↔GO L1]
01000 PUF. F,A
01100 L1:
01200 CDR 0,PIPE(A)↔JUMPE 0,.+3↔CAME 0,A↔POP3J ;EXIT WHEN A IS NOT EMPTY.
01300 LAC R,WORLD↔CAR Q,PIPE(R)
01400 DAP A,PIPE(Q)↔DIP A,PIPE(R)
01500 DIP Q,PIPE(A)↔DAP R,PIPE(A)
01600 POP3J
01700 BEND
00100 ;GEOMETRIC 2D LOCII ROUTINES.
00200
00300 ;QEV(E,V).
00400 SUBR(QEV)
00500 BEGIN QEV
00600 ACCUMULATORS{E,V}
00700 LAC V,ARG1
00800 LAC E,ARG2
00900 LAC 1,CC(E)
01000 LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
01100 LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
01200 RET2
01300 BEND
01400
01500 ;QFEV(F,E,V).
01600 SUBR(QFEV)
01700 BEGIN QFEV
01800 ACCUMULATORS{E,V}
01900 LAC V,ARG1
02000 LAC E,ARG2
02100 LAC 1,CC(E)
02200 LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
02300 LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
02400 PFACE 0,E↔CAME 0,ARG3↔MOVNS 1
02500 RET3
02600 BEND
02700
02800 ;CROSSING(X,Y,E1,E2).
02900 SUBR(CROSSING)
03000 BEGIN CROSSING
03100 ACCUMULATORS{TT,XPTR,YPTR,E1,E2}
03200 LAC E2,ARG1
03300 LAC E1,ARG2
03400 LAC YPTR,ARG3
03500 LAC XPTR,ARG4
03600 LAC AA(E1)↔FMPR BB(E2)
03700 LAC 1,AA(E2)↔FMPR 1,BB(E1)↔FSBR 0,1↔DAC TT
03800 LAC BB(E1)↔FMPR CC(E2)
03900 LAC 1,BB(E2)↔FMPR 1,CC(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC(XPTR)
04000 LAC CC(E1)↔FMPR AA(E2)
04100 LAC 1,CC(E2)↔FMPR 1,AA(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC(YPTR)
04200 RET4
04300 BEND
00100 ;COMPARE EDGE-EDGE.
00200 INTERN XCROSS,YCROSS,ZCROSS,EPSLON,CEECNT
00300 XCROSS: 0↔YCROSS: 0↔ZCROSS: 0
00400 XCRUX: 0↔YCRUX: 0
00500 EPSLON: 0.01↔CEECNT: 0
00600 COMMENT/
00700 -1 EDGES ARE DISJOINT.
00800 0 EDGES E1 AND E2 ARE IDENTICAL.
00900 +Q EDGES INTERSECT IN SOME MANNER.
01000 +1 EDGES CROSS OR TOUCH EACH OTHER.
01100 441 EDGE CROSS EACH OTHER.
01200
01300 +110 PVT(E1) IS JOINED TO PVT(E2).
01400 +120 PVT(E1) IS JOINED TO NVT(E2).
01500 +210 NVT(E1) IS JOINED TO PVT(E2).
01600 +220 NVT(E1) IS JOINED TO NVT(E2).
01700
01800 +401 E1 crosses E2's line.
01900 +201 NVT(E1) within ε of E2's line.
02000 +101 PVT(E1) within ε of E2's line.
02100
02200 + 41 E2 crosses E1's line.
02300 + 21 NVT(E2) within ε of E1's line.
02400 + 11 PVT(E2) within ε of E1's line.
02500 /
02600 ;COMPEE(E1,E2)
02700 SUBR COMPEE
02800 BEGIN COMPEE
02900 ACCUMULATORS{Q1,Q2,E1,E2,V1,V2,U1,U2,S12}
03000 AOS CEECNT
03100 SETZ 1,↔LAC E1,ARG2↔LAC E2,ARG1
03200 CAMN E1,E2↔POP2J; IDENTITY CASE.
03300
03400 ;FETCH ENDPOINTS - RING'A'AROUND TJOINTS TO GET THE JOT.
03500 PVT V1,E1↔NVT V2,E1
03600 PVT U1,E2↔NVT U2,E2
03700 TESTZ V1,1B3↔GO[TJOINT V1,V1↔GO .-2]
03800 TESTZ V2,1B3↔GO[TJOINT V2,V2↔GO .-2]
03900 TESTZ U1,1B3↔GO[TJOINT U1,U1↔GO .-2]
04000 TESTZ U2,1B3↔GO[TJOINT U2,U2↔GO .-2]
04100
04200 ;TEST FOR EDGES ALREADY HAVINGS A VERTEX OR TJOINT IN COMMON.
04300 NIM 1,110↔CAMN V1,U1↔POP2J
04400 NIM 1,120↔CAMN V1,U2↔POP2J
04500 NIM 1,210↔CAMN V2,U1↔POP2J
04600 NIM 1,220↔CAMN V2,U2↔POP2J
00100 LO1←←0 ↔ HI1←←1 ↔ LO2←←2 ↔ HI2←←3
00200
00300 ;TEST FOR X-SPAN NOT OVERLAPPING.
00400 LAC LO1,XPP(V1)↔LAC HI1,XPP(V2)↔CAMG HI1,LO1↔EXCH HI1,LO1
00500 LAC LO2,XPP(U1)↔LAC HI2,XPP(U2)↔CAMG HI2,LO2↔EXCH HI2,LO2
00600 CAMG LO1,HI2↔GO .+4↔FSBR LO1,HI2↔CAMLE LO1,EPSLON↔GO L0
00700 CAMG LO2,HI1↔GO .+4↔FSBR LO2,HI1↔CAMLE LO2,EPSLON↔GO L0
00800
00900 ;TEST FOR Y-SPAN NOT OVERLAPPING.
01000 LAC LO1,YPP(V1)↔LAC HI1,YPP(V2)↔CAMG HI1,LO1↔EXCH HI1,LO1
01100 LAC LO2,YPP(U1)↔LAC HI2,YPP(U2)↔CAMG HI2,LO2↔EXCH HI2,LO2
01200 CAMG LO1,HI2↔GO .+4↔FSBR LO1,HI2↔CAMLE LO1,EPSLON↔GO L0
01300 CAMG LO2,HI1↔GO .+4↔FSBR LO2,HI1↔CAMLE LO2,EPSLON↔GO[L0:
01400 SETO 1,↔POP2J]
01500
01600 SETZ 1,
00100 ;COMPARE E1 AND U1.
00200 LAC Q1,CC(E1)
00300 LAC BB(E1)↔FMPR YPP(U1)↔FADR Q1,0
00400 LAC AA(E1)↔FMPR XPP(U1)↔FADR Q1,0
00500 LACM Q1↔CAMG EPSLON↔TRO 1,10; U1 TOUCHES E1'S LINE.
00600
00700 ;COMPARE E1 AND U2.
00800 LAC Q2,CC(E1)
00900 LAC BB(E1)↔FMPR YPP(U2)↔FADR Q2,0
01000 LAC AA(E1)↔FMPR XPP(U2)↔FADR Q2,0
01100 LACM Q2↔CAMG EPSLON↔TRO 1,20; U2 TOUCHES E1'S LINE.
01200
01300 ;EXIT WHEN U1 AND U2 ARE CLEAR OF E1 ON THE SAME SIDE.
01400 XOR Q1,Q2↔JUMPGE Q1,[TRNE 1,30↔GO .+2↔SETO 1,↔POP2J]
01500 TRO 1,40 ;E1 CROSSES E2'S LINE.
01600
01700 ;COMPARE E2 AND V1.
01800 LAC Q1,CC(E2)
01900 LAC BB(E2)↔FMPR YPP(V1)↔FADR Q1,0
02000 LAC AA(E2)↔FMPR XPP(V1)↔FADR Q1,0
02100 LACM Q1↔CAMG EPSLON↔TRO 1,100; V1 TOUCHES E2'S LINE.
02200
02300 ;COMPARE E2 AND V2.
02400 LAC Q2,CC(E2)
02500 LAC BB(E2)↔FMPR YPP(V2)↔FADR Q2,0
02600 LAC AA(E2)↔FMPR XPP(V2)↔FADR Q2,0
02700 LACM Q2↔CAMG EPSLON↔TRO 1,200; V2 TOUCHES E2'S LINE.
02800
02900 ;EXIT WHEN V1 AND V2 ARE CLEAR OF E2 ON THE SAME SIDE.
03000 XOR Q1,Q2↔JUMPGE Q1,[TRNE 1,300↔GO .+2↔SETO 1,↔POP2J]
03100 TRO 1,400 ;E2 CROSSES E1'S LINE.
03200
03300 ;SOLVE FOR CROSSING LOCUS.
03400 DAC 1,AC1
03500 LAC AA(E1)↔FMPR BB(E2)
03600 LAC 1,AA(E2)↔FMPR 1,BB(E1)↔FSBR 0,1↔DAC TT#
03700 LAC BB(E1)↔FMPR CC(E2)
03800 LAC 1,BB(E2)↔FMPR 1,CC(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC XCROSS
03900 LAC CC(E1)↔FMPR AA(E2)
04000 LAC 1,CC(E2)↔FMPR 1,AA(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC YCROSS
04100 LAC XCROSS↔FMPR MAGX↔FADR SOX↔DAC XCRUX
04200 LAC YCROSS↔FMPR MAGY↔FADR SOY↔DAC YCRUX
04300 LAC 1,AC1↔TRO 1,1↔POP2J
04400 BEND
00100 ;ZEDGE(E) - SOLVE FOR ZDEPTHS AT THE CROSSING(XCROSS,YCROSS).
00200 ;Z←((Z2-Z1)*(XCROSS-X1)/(X2-X1))+Z1
00300 SUBR(ZDEDGE)
00400 BEGIN ZDEDGE
00500 ACCUMULATORS{E,V1,V2}
00600
00700 LAC E,ARG1
00800 PVT V1,E↔NVT V2,E
00900 LACM 0,AA(E)↔LACM 1,BB(E)↔CAMGE 1,0↔GO L
01000
01100 ;WHEN DX ≥ DY:
01200 LAC 1,ZPP(V2)↔FSBR 1,ZPP(V1)
01300 LAC 0,XCROSS↔ FSBR 0,XPP(V1)↔FMPR 1,0
01400 LAC 0,XPP(V2)↔FSBR 0,XPP(V1)↔FDVR 1,0
01500 FADR 1,ZPP(V1)↔DAC 1,ZCROSS↔POP1J
01600
01700 ;WHEN DY > DX:
01800 L: LAC 1,ZPP(V2)↔FSBR 1,ZPP(V1)
01900 LAC 0,YCROSS↔ FSBR 0,YPP(V1)↔FMPR 1,0
02000 LAC 0,YPP(V2)↔FSBR 0,YPP(V1)↔FDVR 1,0
02100 FADR 1,ZPP(V1)↔DAC 1,ZCROSS↔POP1J
02200 BEND
00100 ;VNEW ← EBREAK(EDGE) - VERY MUCH LIKE ESPLIT, BUT WITH MORE FRILLS.
00200 SUBR(EBREAK)
00300 BEGIN EBREAK
00400 ACCUMULATORS{A,B,E,V,Q,R,ENEW,VNEW,S12,ANEW,PV,NV}
00500 ;GET ZDEPTH AT CROSSING.
00600 CALL ZDEDGE,ARG1
00700 ;CREATE A NEW EDGE AND A NEW VERTEX.
00800 CDR E,ARG1↔PVT V,E↔PBODY B,E
00900 SETQ(VNEW,{MKV,B})↔MARK VNEW,(TEMPORARY∨POTENT)
01000 TJOIN. VNEW,VNEW
01100 LAC XCROSS↔DAC XPP(VNEW)↔LAC XCRUX↔XDC. 0,VNEW
01200 LAC YCROSS↔DAC YPP(VNEW)↔LAC YCRUX↔YDC. 0,VNEW
01300 LAC ZCROSS↔DAC ZPP(VNEW)
01400 SETQ(ENEW,{MKE,B})↔MARK ENEW,POTENT
01500 ;COPY EDGE COEFFICIENTS.
01600 SLIMZ AA(E)↔LIM AA(ENEW)↔BLT CC(ENEW)
01700 ;MAKE AN ALT BLOCK FOR ENEW.
01800 MOVEI 1,=10↔CALL GETBLK,1↔ADDI 1,3↔LAC ANEW,1
01900 ALT. ANEW,ENEW↔ALT. ENEW,ANEW
02000 ALT A,E↔LAC -1(A)↔DAC -1(ANEW)↔DAP PUFACE#
02100 ;POTNTE RING IN.
02200 CDR R,WORLD↔CAR Q,POTNTE(R)
02300 DAP ANEW,POTNTE(Q)↔DIP ANEW,POTNTE(R)
02400 DIP Q,POTNTE(ANEW)↔DAP R,POTNTE(ANEW)
02500 ;FOLDE RINGIN.
02600 TESTZ E,FOLDED↔GO[MARK ENEW,FOLDED↔CAR Q,FOLDE(A)
02700 DAP ANEW,FOLDE(Q)↔DIP ANEW,FOLDE(A)
02800 DIP Q,FOLDE(ANEW)↔DAP A,FOLDE(ANEW)↔GO .+1]
02900 ;UPDATE V'S FIRST PTR WHEN NECESSARY.
03000 PED 0,V↔CAMN 0,E↔PED. ENEW,V
03100 ;PLACE VNEW BETWEEN E AND ENEW.
03200 PED. ENEW,VNEW↔PVT PV,E↔PVT. PV,ENEW
03300 PVT. VNEW,E↔NVT. VNEW,ENEW
03400 PFACE 0,E↔PFACE. 0,ENEW
03500 NFACE 0,E↔NFACE. 0,ENEW
03600 ;NEW UPPER WINGS ARE LIKE THE OLDE;
03700 PCW 0,E↔CALL WING,0,ENEW
03800 NCCW 0,E↔CALL WING,0,ENEW
03900 ;EDGES POINT AT EACH OTHER ACROSS VNEW.
04000 NCCW.. ENEW,E↔PCW.. ENEW,E
04100 NCW.. E,ENEW↔PCCW.. E,ENEW
00100 ;WHEN NV IS POTENT AND PV ISN'T, RINGO E FROM THE PIPE.
00200 NVT NV,E↔TEST NV,POTENT↔GO L1↔TESTZ PV,POTENT↔GO L1
00300 CAR Q,PIPE(A)↔CDR R,PIPE(A)
00400 DAP R,PIPE(Q)↔DIP Q,PIPE(R)
00500 MARKZ A,1B17 ;PVHID.
00600
00700 ;WHEN PV IS HIDDEN OR VISIBLE THEN RING ENEW INTO THE PIPE.
00800 L1: TESTZ PV,POTENT↔GO L2
00900 TESTZ PV,VISIBLE
01000 GO[CALL E.SHOW,PUFACE,ENEW,PV↔GO .+1]
01100
01200 L2: LAC 1,VNEW↔POP1J
01300
01400 BEND
00100 ;JFUSE(J1,J2) - JOINT FUSION.
00200 SUBR(JFUSE)
00300 BEGIN JFUSE
00400 ACCUMULATORS{J1,J2,NJ1,NJ2,JTOP,JBOT}
00500
00600 CDR J1,ARG2↔CDR J2,ARG1
00700
00800 ;GET THE LAST-JUT → JOT.
00900 TESTZ J1,1B3↔TJOINT J1,J1
01000 LAC NJ1,J1
01100 TESTZ J1,1B3↔GO[LAC NJ1,J1↔TJOINT J1,J1↔GO .-2]
01200
01300 TESTZ J2,1B3↔TJOINT J2,J2
01400 LAC NJ2,J2
01500 TESTZ J2,1B3↔GO[LAC NJ2,J2↔TJOINT J2,J2↔GO .-2]
01600
01700 ;GET TOP JOT INTO J1 & JTOP.
01800 LAC ZPP(J1)↔CAML ZPP(J2)
01900 GO .+3↔EXCH J1,J2↔EXCH NJ1,NJ2
02000 DAC J1,JTOP
02100 ;GET BOTTOM JUT INTO JBOT.
02200 LAC JBOT,NJ1
02300 LAC ZPP(NJ1)
02400 CAML ZPP(NJ2)↔LAC JBOT,NJ2
02500
02600 ;SET THE TJOINT BITS.
02700 MARK J1,1B4;JOT
02800 MARKZ J2,1B4
02900 MARK J2,1B3;JUT
03000 ;MERGE J1'S AND J2'S TJOINT RINGS IN ORDER BY ZPP;
03100 ;ZPP HIGH IS VISIBLE AND NEAR - ZPP LOW IS HIDDEN AND FAR.
03200 TJOIN. JTOP,JBOT
03300 CAMN J1,NJ1↔GO[TJOIN. JBOT,JTOP↔POP2J]
03400 L0: LAC 0,ZPP(J2) ;RING-2'S DEPTH.
03500 LAC NJ1,J1 ;NEAREST JOINT UN-MERGED.
03600 L1: TJOINT J1,J1 ;NEXT JOINT OUT ON RING-1.
03700 CAMN J1,JTOP ;TEST FOR END OF RING.
03800 POP2J
03900 CAMGE ZPP(J1) ;SKIP J2 NEARER THAN J1.
04000 GO L1 ;RING-1 IS STILL THE NEAREST.
04100 TJOIN. J2,NJ1 ;NEAREST JOINT NOW POINTS AT OTHER RING.
04200 EXCH J1,J2 ;SWAP THE RINGS.
04300 GO L0
04400 BEND
00100 ;MAKE TJOINT (FOLD,EDGE,Q) OF MOST RECENT COMPEE.
00200 ;SUBR(MKTJ)
00300 ;BEGIN MKTJ
00100 ;ZDEPTH(F,V)
00200 SUBR(ZDEPTH)
00300 BEGIN ZDEPTH
00400 ACCUMULATORS{F,V}
00500 LAC V,ARG1
00600 LAC F,ARG2
00700 LAC 1,KK(F)
00800 LAC AA(F)↔FMPR XPP(V)↔FSBR 1,0
00900 LAC BB(F)↔FMPR YPP(V)↔FSBR 1,0
01000 FDVR 1,CC(F)
01100 RET2
01200 BEND
01300
01400 ;ZDALT(F,X,Y)
01500 SUBR(ZDALT)
01600 BEGIN ZDALT
01700 ACCUMULATORS{F}
01800 LAC F,ARG3
01900 LAC 1,KK(F)
02000 LAC AA(F)↔FMPR ARG2↔FSBR 1,0
02100 LAC BB(F)↔FMPR ARG1↔FSBR 1,0
02200 FDVR 1,CC(F)
02300 RET3
02400 BEND
02500
02600 ;UFACE(E,V)
02700 SUBR(UFACE)
02800 BEGIN UFACE
02900 ACCUMULATORS{E,V,XE}
03000 LAC E,ARG2↔ALT XE,E
03100 NVT V,E↔CAMN V,ARG1↔GO[NUF 1,XE↔RET2]
03200 PVT V,E↔CAMN V,ARG1↔GO[PUF 1,XE↔RET2]
03300 FATAL(UFACE)
03400 LIT
03500 BEND
03600
03700 ;UFACE.(Q,E,V)
03800 SUBR(UFACE.)
03900 BEGIN UFACE.
04000 ACCUMULATORS{Q,E,V,XE}
04100 CDR E,ARG2↔ALT XE,E
04200 CDR Q,ARG3
04300 NVT V,E↔CAMN V,ARG1↔GO[NUF. Q,XE↔RET3]
04400 PVT V,E↔CAMN V,ARG1↔GO[PUF. Q,XE↔RET3]
04500 FATAL(UFACE.)
04600 LIT
04700 BEND
00100 SUBR(POTEN.)
00200 LAC 1,ARG1↔MARKZ 1,VISIBLE↔MARK 1,POTENT↔RET1
00300 SUBR(HIDE.)
00400 LAC 1,ARG1↔MARKZ 1,POTENT∨VISIBLE↔RET1
00500 SUBR(VISIB.)
00600 LAC 1,ARG1↔MARK 1,VISIBLE↔MARKZ 1,POTENT↔RET1
00700 SUBR(FOLD.)
00800 LAC 1,ARG1↔MARK 1,FOLDED ↔RET1
00900 SUBR(TJUT.)
01000 LAC 1,ARG1↔MARK 1,1B3↔RET1
01100 SUBR(TJOT.)
01200 LAC 1,ARG1↔MARK 1,1B4↔RET1
01300 SUBR(TJUT)
01400 LAC 1,ARG1↔CAR 1,(1)↔ANDI 1,(1B3)↔RET1
01500 SUBR(TJOT)
01600 LAC 1,ARG1↔CAR 1,(1)↔ANDI 1,(1B4)↔RET1
01700 SUBR(TJ)
01800 LAC 1,ARG1↔CAR 1,(1)↔ANDI 1,(3B4)↔RET1
01900 SUBR(PVHID)
02000 LAC 1,ARG1↔ALT 1,1↔CAR 1,(1)↔ANDI 1,1↔RET1
02100 SUBR(NVHID)
02200 LAC 1,ARG1↔ALT 1,1↔CAR 1,(1)↔ANDI 1,2↔RET1
02300 SUBR(PVHID.)
02400 LAC 1,ARG1↔ALT 1,1↔CAR(1)↔IORI 1↔DIP(1)↔RET1
02500 SUBR(NVHID.)
02600 LAC 1,ARG1↔ALT 1,1↔CAR(1)↔IORI 2↔DIP(1)↔RET1
02700 SUBR(PVHIDZ)
02800 LAC 1,ARG1↔ALT 1,1↔CAR(1)↔ANDI 2↔DIP(1)↔RET1
02900 SUBR(NVHIDZ)
03000 LAC 1,ARG1↔ALT 1,1↔CAR(1)↔ANDI 1↔DIP(1)↔RET1
03100
03200 END